#lang racket


(require "../com.rkt")

(require "bounding-box.rkt"
         (prefix-in rh: "com.rkt"))


(provide (rename-out (rh:enable-redraw enable-redraw))
         (rename-out (rh:world-xy-plane world-xy-plane))
         (rename-out (rh:world-yz-plane world-yz-plane))
         (rename-out (rh:world-zx-plane world-zx-plane))
         
         rhino-shape?
         join-shapes
         
         add-box
         add-circle
         add-cone
         add-cylinder
         add-interp-curve
         add-loft-surface
         add-sphere
         
         boolean-difference
         boolean-intersection
         boolean-union
         
         bounding-box
         
         copy         
         delete
         delete-all-objects
         is-object
         move
         rotate
         scale)


; shape

(define-struct rhino-shape
  (ids))


(define (list<-shape shape)
  (let ((id (rhino-shape-ids shape)))
    (if (list? id)
        id
        (list id))))

(define (join-shapes shape1 shape2)
  (make-rhino-shape
   (append
    (list<-shape shape1)
    (list<-shape shape2))))

(define (shape<-vector<string> objects)
  (make-rhino-shape (vector->list objects)))

(define (vector<string><-shape shape)
  (let ((id (rhino-shape-ids shape)))
    (if (list? id)
        (list->vector id)
        (vector id))))

(define (vector<string><-list<shape> shapes)
  (apply vector-append (map vector<string><-shape shapes)))

; /shape


; loft

(define (loft-type s)
  (cond ((eq? s 'normal) 0)
        ((eq? s 'loose) 1)
        ((eq? s 'straight) 2)
        ((eq? s 'tight) 3)
        ((eq? s 'developable) 4)
        (else
         (error 'loft-type "Unhandled loft type"))))

(define (loft-style s)
  (cond ((eq? s 'none) 0)
        ((eq? s 'rebuild) 1)
        ((eq? s 'refit) 2)
        (else
         (error 'loft-style "Unhandled loft style"))))

; /loft


(define (add-circle plane radius)
  (make-rhino-shape
   (rh:add-circle
    plane
    (real<-number radius))))

(define (add-box corners)
  (make-rhino-shape
   (rh:add-box
    (vector<real><-list<number> corners))))

(define (add-cone base height radius cap)
  (make-rhino-shape
   (rh:add-cone
    (vector<real><-point base)
    (vector<real><-point height)
    (real<-number radius)
    cap)))

(define (add-cylinder base height radius cap)
  (make-rhino-shape
   (rh:add-cylinder
    (vector<real><-point base)
    (vector<real><-point height)
    (real<-number radius)
    cap)))

(define (add-interp-curve points)
  (make-rhino-shape
   (rh:add-interp-curve
    (apply vector-append (list<vector<real>><-list<point> points)))))

(define add-loft-surface
  (case-lambda
    ((shapes)
     (begin0
       (make-rhino-shape
        (rh:add-loft-surface
         (vector<string><-list<shape> shapes)))
       (map delete shapes)))
    ((shapes closed)
     (begin0
       (make-rhino-shape
        (rh:add-loft-surface
         (vector<string><-list<shape> shapes)
         closed))
       (map delete shapes)))
    ((shapes start end type style value closed)
     (begin0
       (make-rhino-shape
        (rh:add-loft-surface
         (vector<string><-list<shape> shapes)
         start
         end
         (loft-type type)
         (loft-style style)
         value
         closed))
       (map delete shapes)))))

(define (add-sphere center radius)
  (make-rhino-shape
   (rh:add-sphere
    (vector<real><-point center)
    (real<-number radius))))


; operations

(define (extrude)
  #f)

(define (binary-boolean operation shape1 shape2 delete)
  (let ((result (operation
                 (vector<string><-shape shape1)
                 (vector<string><-shape shape2)
                 delete)))
    (if (void? result)
        result
        (shape<-vector<string> result))))

(define (boolean-difference shape1 shape2 delete)
  (binary-boolean rh:boolean-difference shape1 shape2 delete))

(define (boolean-intersection shape1 shape2 delete)
  (binary-boolean rh:boolean-intersection shape1 shape2 delete))

(define (boolean-union shape1 shape2 delete)
  (let ((result (rh:boolean-union
                 (vector-append
                  (vector<string><-shape shape1)
                  (vector<string><-shape shape2))
                 delete)))
    (if (void? result)
        result
        (shape<-vector<string> result))))

(define (bounding-box shape)
  (bbox
   (list<point><-vector<vector<real>>
    (rh:bounding-box (vector<string><-shape shape)))))

(define (copy shape)
  (shape<-vector<string>
   (rh:copy-objects
    (vector<string><-shape shape))))

(define (delete shape)
  (rh:delete-objects
   (vector<string><-shape shape)))

(define (delete-all-objects)
  (let ((objects (rh:all-objects)))
    (unless (void? objects)
      (rh:delete-objects objects))))

(define (is-object shape)
  (andmap rh:is-object (vector->list (vector<string><-shape shape))))

(define move
  (case-lambda
    ((shape translation)
     (shape<-vector<string>
      (rh:move-objects
       (vector<string><-shape shape)
       (vector<real><-point translation))))
    ((shape start end)
     (shape<-vector<string>
      (rh:move-objects
       (vector<string><-shape shape)
       (vector<real><-point start)
       (vector<real><-point end))))))

(define (rotate shape point angle axis copy)
  (shape<-vector<string>
   (rh:rotate-objects
    (vector<string><-shape shape)
    (vector<real><-point point)
    (real<-number angle)
    (vector<real><-point axis)
    copy)))

(define (scale shape origin scale copy)
  (shape<-vector<string>
   (rh:scale-objects
    (vector<string><-shape shape)
    (vector<real><-point origin)
    (vector<real><-point scale)
    copy)))